Pascal Super Library/Pascal Super Library (CW International)(1997).bin/FILE_UTL/QMOVE/QMOVE.PAS

Pascal/Delphi Source File | 1989-01-31 | 9KB | 322 lines

{$V-,S-,R-,I-}
{--------------------------------------------------------------}
{                                                              }
{             Saved as: QMOVE.PAS                              }
{               Author: Pat Anderson                           }
{             Language: TP5                                    }
{              Purpose: File moving utility                    }
{        Last modified: Monday, 1-30-1989                      }
{                                                              }
{--------------------------------------------------------------}

PROGRAM QMove;

USES
  Crt,
  Dos,
  Exists40;

TYPE
  Str2  = string[2];
  Str64 = string[64];

VAR
  CurrentDrive,
  SourceDrive,
  DestinationDrive       : Str2;
  SourceFiles,
  DestinationDir,
  SourcePath             : DirStr;
  SourceName             : NameStr;
  SourceExt              : ExtStr;
  OnSameDrive            : boolean;
  DirInfo                : SearchRec;
  DiskBuf                : array [1..16384] of byte;
  BytesRead,
  BytesWritten           : integer;
  OverwriteFile          : boolean;

PROCEDURE ShowCorrectUsage;
  BEGIN
    WriteLn;
    WriteLn ('Usage:');
    WriteLn;
    WriteLn ('  QMOVE SourceFile(s) DestinationDir');
    WriteLn;
    WriteLn ('Full paths may be specified for both Source and Destination.');
    WriteLn ('Wildcards ''?'' and ''*'' are permitted in SourceFile(s).');
    WriteLn ('If DestinationDir is not specified, SourceFile(s) will be moved');
    WriteLn ('to current directory of logged drive.');
    WriteLn;
    Halt (1);
  END;

FUNCTION ToUpper (S : string) : string;
  VAR
    i : byte;
  BEGIN
    FOR i := 1 TO Length (S) DO
      S[i] := UpCase (S[i]);
    ToUpper := S;
  END; {of function ToUpper}

FUNCTION GetCurrentDrive : Str2;
  VAR
    S : string;
  BEGIN
    GetDir (0,S);
    GetCurrentDrive := Copy (S,1,2);
  END; {of function GetCurrentDrive}

PROCEDURE ConfirmOverWrite;
  VAR
    Answer : char;
  BEGIN
    WriteLn;
    WriteLn
      ('File ',DirInfo.Name,' in ',DestinationDir,' will be OVERWRITTEN');
    WriteLn ('Do you want to overwrite the existing file? (Y/N)');
    REPEAT
      Answer := UpCase (ReadKey);
    UNTIL Answer IN ['Y','N'];
    IF Answer = 'Y' THEN
      OverwriteFile := TRUE
    ELSE
      OverwriteFile := FALSE;
  END;

PROCEDURE MoveByCopyingAndDeleting;
  VAR
    SourceFile,
    DestinationFile : file;
    ByteCount : word;

  BEGIN
    FindFirst (SourceFiles,AnyFile,DirInfo);
    WriteLn;

    WHILE DosError = 0 DO
      BEGIN
        IF (DirInfo.Attr <> Directory) AND (DirInfo.Attr <> VolumeID) THEN
          BEGIN
            IF FileExists (DestinationDir + DirInfo.Name) THEN
              ConfirmOverwrite;
            IF OverwriteFile THEN
              BEGIN
                Write
                  ('Moving ', SourcePath + DirInfo.Name);
                GotoXY (35,WhereY);
                Write ('to');
                GotoXY (45,WhereY);
                WriteLn (DestinationDir + DirInfo.Name);
                Assign (SourceFile, SourcePath + DirInfo.Name);
                Reset (SourceFile,1);
                Assign (DestinationFile, DestinationDir + DirInfo.Name);
                Rewrite (DestinationFile,1);

                {Copy algorithm from Tom Swan,
                 Mastering Turbo Pascal 4.0, p. 161}
                REPEAT
                  BlockRead (SourceFile, DiskBuf,
                             SizeOf(DiskBuf), BytesRead);
                  IF BytesRead > 0 THEN
                    BEGIN
                      BlockWrite (DestinationFile, DiskBuf,
                                  BytesRead, BytesWritten);
                      IF BytesRead <> BytesWritten THEN
                        BEGIN
                          {Code to inform user of disk write
                           error, close files and quit}
                        END;
                    END;
                UNTIL BytesRead = 0;
                Close (SourceFile);
                Erase (SourceFile);
                Close (DestinationFile);
              END; {IF OverwriteFile}
          END; {IF not Directory or Volume ID}
        FindNext (DirInfo);
    END; {while}
  END;

PROCEDURE MoveByRenaming;
  VAR
    F, ZapF : file;
    SkipFile : boolean;
  BEGIN
    SkipFile := FALSE;
    FindFirst (SourceFiles,AnyFile,DirInfo);
    WriteLn;

    WHILE DosError = 0 DO
      BEGIN
        IF (DirInfo.Attr <> Directory) AND (DirInfo.Attr <> VolumeID) THEN
          BEGIN
            IF FileExists (DestinationDir + DirInfo.Name) THEN
              BEGIN
                ConfirmOverwrite;
                IF OverWritefile THEN
                  BEGIN
                    Assign (ZapF, DestinationDir + DirInfo.Name);
                    Erase (ZapF);
                    SkipFile := FALSE;
                  END
                ELSE
                  SkipFile := TRUE;
              END; {IF FileExists}

            IF NOT SkipFile THEN
              BEGIN
                Write
                  ('Moving ', SourcePath + DirInfo.Name);
                GotoXY (35, WhereY);
                Write ('to');
                GotoXY (45, WhereY);
                WriteLn (DestinationDir + DirInfo.Name);
                Assign (F,SourcePath + DirInfo.Name);
                Rename (F,DestinationDir + DirInfo.Name);
              END; {IF ConfirmOverwrite}
          END; {IF not a directory and not a volume label}
        FindNext (DirInfo);
      END;  {WHILE}
  END; {of procedure MoveByRenaming}

PROCEDURE ValidateDestination;
  VAR
    L : integer;
  BEGIN
    IF (Length (DestinationDir) = 2) AND (DestinationDir[2] = ':') THEN
      BEGIN
        DestinationDir := DestinationDir + '\';
        Exit;
      END;

    L := Length (DestinationDir) - 1;

    IF DirExists (Copy (DestinationDir,1,L)) THEN
      Exit
    ELSE IF DosError = 3 THEN
      BEGIN
        WriteLn;
        WriteLn
          ('Destination directory ',
           DestinationDir,
           ' does not exist');
        WriteLn;
        Halt (2);
      END
    ELSE
      BEGIN
        WriteLn;
        WriteLn
          ('Error accessing drive ', DestinationDrive);
        WriteLn;
        Halt (2);
      END;
  END;    {of procedure ValidateDestination}

PROCEDURE ValidateSource;
  VAR
    L          : integer;
  BEGIN
    L := Length (SourcePath) - 1;

    IF DirExists (Copy (SourcePath,1,L)) THEN
      BEGIN
        {do nothing}
      END
    ELSE
      BEGIN
        WriteLn;
        WriteLn
          ('Path to source files ',SourcePath,' does not exist');
        WriteLn;
        Halt (3);
      END;

    FindFirst (SourceFiles, AnyFile, DirInfo);
    IF DosError = 0 THEN
      BEGIN
        {do nothing}
      END
    ELSE
      IF DosError = 18 THEN
        BEGIN
          WriteLn;
          WriteLn
            ('No files matching ',SourceFiles,' found');
          WriteLn;
          Halt (3);
        END
    ELSE
      BEGIN
        WriteLn;
        WriteLn ('Error accessing drive ',SourceDrive);
        WriteLn;
        Halt (3);
      END;
  END; {of procedure ValidateSource}

PROCEDURE GetSourceAndDestination;
  BEGIN
    IF ParamCount < 1 THEN
      ShowCorrectUsage;

    CurrentDrive := GetCurrentDrive;
    SourceFiles := ToUpper (ParamStr (1));

    IF ParamCount = 2 THEN
      DestinationDir := ToUpper (ParamStr (2))
    ELSE
      GetDir (0,DestinationDir);

    IF SourceFiles[2] = ':' THEN
      SourceDrive := Copy (SourceFiles,1,2)
    ELSE
      SourceDrive := CurrentDrive;

    FSplit (SourceFiles, SourcePath, SourceName, SourceExt);
    IF SourcePath = '' THEN
      BEGIN
        GetDir (0, SourcePath);
        SourceFiles := SourcePath + '\' + SourceName + SourceExt;
      END;

    IF SourcePath[Length (SourcePath)] <> '\' THEN
      SourcePath := SourcePath + '\';

    IF DestinationDir[2] = ':' THEN
      DestinationDrive := Copy (DestinationDir,1,2)
    ELSE
      BEGIN
        DestinationDrive := CurrentDrive;
        DestinationDir := DestinationDrive + DestinationDir;
      END;

    IF DestinationDir[Length(DestinationDir)] <> '\' THEN
      DestinationDir := DestinationDir + '\';

    IF SourceDrive = DestinationDrive THEN
      OnSameDrive := TRUE
    ELSE
      OnSameDrive := FALSE;
  END; {of procedure GetSourceAndDestination}

PROCEDURE ShowTitle;
  BEGIN
    WriteLn ('QMOVE - Quick File Move Utility');
    WriteLn ('Public Domain, 1988, by Pat Anderson');
  END;

BEGIN {MAIN}
  OverwriteFile := TRUE;
  ShowTitle;
  GetSourceAndDestination;
  ValidateSource;
  ValidateDestination;
  IF OnSameDrive THEN
    MoveByRenaming
  ELSE
    MoveByCopyingAndDeleting;
END.